{-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses #-}
-- {-# OPTIONS_GHC -fno-warn-orphans  #-}

{- |
Module      :  Control.Monad.ErrorMonoid
Copyright   :  (c) Dmitry Olshansky 2010,
License     :  BSD-style (see the file libraries/base/LICENSE)

Maintainer  :  olshanskydr@gmail.com
Stability   :  experimental
Portability :  non-portable (multi-parameter type classes)

A wrapper for ErrorT with changed implementation of MonadPlus

[Computation type:] Computations which may fail or throw exceptions.

[Binding strategy:] Failure records information about the cause\/location
of the failure. Failure values bypass the bound function,
other values are used as inputs to the bound function.

[Useful for:] Building computations from sequences of functions that may fail
or using exception handling to structure error handling.

[Zero and plus:] Zero is represented by an mempty error and the plus operation
executes its second argument if the first fails and mappend exceptions if both failed.

-}

module Control.Monad.ErrorMonoid (
    module Control.Monad.Error.Class,
    ErrorMonoidT(..),
    mapErrorMonoidT,
    module Control.Monad,
    -- module Control.Monad.Fix,
    -- module Control.Monad.Trans,
  ) where

import Control.Monad
import Control.Monad.Error
import Control.Monad.Cont.Class
import Control.Monad.Error.Class
import Control.Monad.RWS.Class
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Writer.Class
-- import Control.Monad.Fix ()
-- import Control.Monad.Trans ()

import Control.Monad.Instances ()
import Data.Monoid
import Data.Function (on)
{-
-- where is it used?
instance (Error e) => MonadPlus (Either e) where
    mzero            = Left noMsg
    Left _ `mplus` n = n
    m      `mplus` _ = m
-}

newtype ErrorMonoidT e m a = ErrorMonoidT { runErrorMonoidT :: ErrorT e m a }

mapErrorMonoidT :: (m (Either e a) -> n (Either e' b))
          -> ErrorMonoidT e m a
          -> ErrorMonoidT e' n b
mapErrorMonoidT f m = ErrorMonoidT $ mapErrorT f (runErrorMonoidT m)

instance (Monad m) => Functor (ErrorMonoidT e m) where
    fmap f = ErrorMonoidT . fmap f . runErrorMonoidT

instance (Monad m, Error e) => Monad (ErrorMonoidT e m) where
    return = ErrorMonoidT . return
    m >>= k  = ErrorMonoidT (runErrorMonoidT m >>= runErrorMonoidT . k)
    fail = ErrorMonoidT . fail

instance (Monad m, Error e, Monoid e) => MonadPlus (ErrorMonoidT e m) where
    mzero       = ErrorMonoidT mzero
    m `mplus` n = ErrorMonoidT $ ErrorT $ do
        a <- runErrorT $ runErrorMonoidT m
        case a of
            Left  l -> do
                b <- runErrorT $ runErrorMonoidT n
                case b of 
                    Left l' -> return $ Left (l `mappend` l')
                    r -> return r 
            r -> return r

instance (MonadFix m, Error e) => MonadFix (ErrorMonoidT e m) where
    mfix f = ErrorMonoidT $ mfix (runErrorMonoidT . f)

instance (Monad m, Error e) => MonadError e (ErrorMonoidT e m) where
    throwError s    = (ErrorMonoidT . throwError) s
    catchError m n = ErrorMonoidT $ runErrorMonoidT m `catchError` (runErrorMonoidT . n)

-- ---------------------------------------------------------------------------
-- Instances for other mtl transformers

instance (Error e) => MonadTrans (ErrorMonoidT e) where
    lift = ErrorMonoidT . lift

instance (Error e, MonadIO m) => MonadIO (ErrorMonoidT e m) where
    liftIO = lift . liftIO

{-
instance (Error e, MonadCont m) => MonadCont (ErrorMonoidT e m) where
    callCC = ErrorMonoidT . callCC
-}

instance (Error e, MonadRWS r w s m) => MonadRWS r w s (ErrorMonoidT e m)

instance (Error e, MonadReader r m) => MonadReader r (ErrorMonoidT e m) where
    ask       = lift ask
    local f   = ErrorMonoidT . local f . runErrorMonoidT

instance (Error e, MonadState s m) => MonadState s (ErrorMonoidT e m) where
    get = lift get
    put = lift . put

instance (Error e, MonadWriter w m) => MonadWriter w (ErrorMonoidT e m) where
    tell   = lift . tell
    listen = ErrorMonoidT . listen . runErrorMonoidT
    pass   = ErrorMonoidT . pass . runErrorMonoidT

